home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Shareware Grab Bag
/
Shareware Grab Bag.iso
/
007
/
tttool30.arc
/
IO.TTT
< prev
next >
Wrap
Text File
|
1986-09-28
|
16KB
|
551 lines
{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}
{ }
{ T E C H N O J O C K S T U R B O T O O L K I T }
{ }
{ Module : IO.TTT }
{ }
{ Version : 3.0 , October 1, 1986 }
{ }
{ Purpose : Fullscreen editing procedures }
{ }
{ Requirements : Decl.TTT }
{ Fastwrit.TTT }
{ Window.ttt }
{ Misc.ttt }
{ }
{ Procedures: }
{ IO_Setfields(No_of_fields:byte); }
{ IO_SetColors(HiFore,Hiback,LoFore,LoBack,MsgFore,MsgBack:byte); }
{ IO_DefineMsg(DefID,DefX,DefY : byte; DefString : string80); }
{ IO_DefineStr(DefID,DefU,DefD,DefL,DefR,DefX,DefY:byte; }
{ Var DefString : string80; }
{ DefFormat : string80); }
{ IO_HelpProc(location : integer); }
{ IO_DisplayFields; }
{ IO_AllowEsc(OK:boolean); }
{ IO_SoundBeeper(OK:boolean); }
{ IO_Edit(var Return_code : integer); }
{ IO_ResetFields; }
{ }
{ Bob Ainsbury }
{ Technojock }
{ Houston }
{ (713) 293-2760 }
{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}
Procedure Abend(Code:byte;value:real); {fatal error -- msg and halt}
var Message:string80;
begin
{Clrscr;}
Case Code of
1 : Message :=
'Fatal Error 1 : Invalid value of '+Real_to_Str(value,0)+
' in IO_SetFields with a MaxInputFields of '+Real_to_Str(MaxInputFields,0);
2 : Message :=
'Fatal Error 2 : Insufficient Memory on Heap. Available '
+Real_to_Str(MemAvail_in_Bytes,0)+'. Required '+Real_to_Str(value,0);
3 : Message :=
'Fatal Error 3 : Define IO_Setfields before IO_DefineStr';
4 : Message :=
'Fatal Error 4 : IO_DefineStr ID: '+Real_to_Str(value,0)+' out of range';
5 : Message :=
'Fatal Error 5 : Invalid exit field defined in IO_DefinStr ID: '
+Real_to_Str(value,0);
6 : message :=
'Fatal Error 6 : Invalid X or Y value defined in IO_DefineStr ID: '
+Real_to_Str(value,0);
7 : Message :=
'Fatal Error 7 : Define IO_Setfields before IO_DefineMsg';
8 : Message :=
'Fatal Error 8 : IO_DefineMsg ID: '+Real_to_Str(value,0)+' out of range';
9 : message :=
'Fatal Error 9 : Invalid X or Y value defined in IO_DefineMsg ID: '
+Real_to_Str(value,0);
10 : Message :=
'Fatal Error 10 : Only use IO_ResetFields after IO_Setfields';
11 : Message :=
'Fatal Error 11 : IO_Setfields already operative, reset with IO_Resetfields';
else Message := 'Aborting';
end; {case}
WriteAT(1,12,yellow,red,Message);
Repeat Until keypressed;
Halt;
end; {proc Abend}
Procedure Ding;
begin
If IO_Settings.IO_BeepOn then
sound(750);delay(150);nosound;
end; {proc Ding}
Procedure Jumpto(location:integer);
begin
inline($1e/$55/$8b/$ec/$8b/$5e/$0a/$ff/$d3/$5d/$1f);
end;
Procedure IO_HelpProc(location : integer);
begin
IO_Settings.HelpAddress := location;
end;
Procedure InsertMode; {change cursor style when in insert mode}
begin
IO_Settings.IO_Insert := not IO_Settings.IO_Insert;
If IO_Settings.IO_Insert then
SizeCursor(4,7)
else
SizeCursor(6,7);
end;
Procedure IO_Setfields(No_of_fields:byte);
var I:integer;
Room_needed : real;
begin
If IO_Settings.IO_FieldsSet then Abend(11,0); {already set}
If No_of_Fields in [1..MaxInputFields] then
begin
Room_needed := sizeof(FieldDefn[0]^)*(1+No_of_fields);
If MemAvail_in_bytes > Room_needed then
begin
For I := 0 to No_of_fields do
begin
New(FieldDefn[I]);
New(FieldDefn[I]^.InString);
with FieldDefn[I]^ do
begin
Upfield := 0;
Downfield := 0;
Leftfield := 0;
Rightfield := 0;
X := 0;
Y := 0;
InString^ := '';
StrLength := 0;
Format := '';
Message := '';
MsgX := 0;
MsgY := 0;
CursorX := 0;
CursorInit := 0;
StrLocX := 1;
end;
end;
IO_Settings.TotalFields := No_of_Fields;
IO_Settings.IO_FieldsSet := true;
end
else {not enough heap space}
Abend(2,Room_needed); {end MemAvail If clause}
end
else {Invalid No_of_fields}
Abend(1,No_of_fields);
end; {Proc IO_SetFields}
Procedure IO_SetColors(HiFore,Hiback,LoFore,LoBack,MsgFore,MsgBack:byte);
begin
With IO_Settings do
begin
HiF := HiFore;
HiB := HiBack;
LoF := LoFore;
LoB := LoBack;
MsgF := MsgFore;
MsgB := MsgBack;
end;
end; {Proc IO_SetColors}
Procedure IO_DefineMsg(DefID,DefX,DefY : byte; DefString : string80);
begin
If not IO_Settings.IO_FieldsSet then abend(7,0);
If (DefID < 1) or (DefID > IO_Settings.TotalFields) then abend(8,DefID);
If (DefX < 1) or (DefX > 80) or (DefY < 1) or (DefY > 25) then abend(9,DefID);
With FieldDefn[Defid]^ do
begin
MsgX := DefX;
MsgY := DefY;
Message := DefString;
end;
end; {proc IO_DefineMsg}
Procedure IO_DefineStr(DefID,DefU,DefD,DefL,DefR,DefX,DefY:byte;
Var DefString : string80;
DefFormat : string80);
Function Max_string_length : byte;
var I,Counter : byte;
begin
Counter := 0;
For I := 1 to length(DefFormat) do
if (DefFormat[I] in FmtChars) then
Counter := counter + 1;
Max_string_length := Counter;
end; {sub func Max_String_Length}
Function Pos_of_First_Input_Char: byte;
var Counter : byte;
begin
Counter := 0;
Repeat
Counter := Counter + 1;
Until DefFormat[Counter] in FmtChars;
Pos_of_First_Input_Char := FieldDefn[DefID]^.X + counter - 1;
end;
begin
If not IO_Settings.IO_FieldsSet then Abend(3,0);
If (DefID < 1) or (DefID>IO_Settings.TotalFields) then Abend(4,Defid);
If (DefU < 0) or (DefU > IO_Settings.TotalFields)
or (DefD < 0) or (DefD > IO_Settings.TotalFields)
or (DefL < 0) or (DefL > IO_Settings.TotalFields)
or (DefR < 0) or (DefR > IO_Settings.TotalFields)
then Abend(5,Defid);
If (DefX < 1) or (DefX > 80)
or (DefY < 1) or (DefY > 25)
then Abend(6,Defid);
With FieldDefn[DefID]^ do
begin
Upfield := DefU;
Downfield := DefD;
Leftfield := DefL;
Rightfield := DefR;
X := DefX;
Y := DefY;
InString := ptr(seg(DefString),ofs(DefString));
StrLength := Max_String_length;
Format := DefFormat;
CursorX := Pos_of_First_Input_Char;
CursorInit := Pos_of_First_Input_Char;
end;
end; {proc IO_DefineStr}
Function IO_FmtStr(Str,Fmt:string80):string80;
var
TempStr : string80;
I,J : byte;
begin
J := 0;
For I := 1 to length(Fmt) do
begin
If not (Fmt[I] in FmtChars) then
begin
TempStr[I] := Fmt[I] ; {force any none format charcters into string}
J := J + 1;
end
else {format character}
begin
If I - J <= length(Str) then
TempStr[I] := Str[I - J]
else
TempStr[I] := ' '; {pad with blanks}
end;
end;
TempStr[0] := char(length(Fmt)); {set initial byte to string length}
IO_FmtStr := Tempstr;
end; {Func FmtStr}
Function Underline(Str:string80):string80;
var I : integer;
begin
If IO_Settings.IO_PutUnderline then
for I := 1 to length(Str) do
If Str[I] = ' ' then Str[I] := '_';
Underline := Str;
end; {func Underline}
Procedure Hilight(ID:byte); {display cell in bright colors}
begin
with FieldDefn[ID]^ do
WriteAT(X,Y,IO_Settings.HiF,IO_Settings.HiB,Underline(IO_FmtStr(InString^,Format)));
end;
Procedure LoLight(ID:byte); {display cell in dim colors}
begin
with FieldDefn[ID]^ do
WriteAT(X,Y,IO_Settings.LoF,IO_Settings.LoB,Underline(IO_FmtStr(InString^,Format)));
end;
Procedure IO_DisplayFields;
var I : integer;
begin
For I := 1 to IO_Settings.TotalFields do
LoLight(I);
IO_Settings.Displayed := true;
end;
Procedure IO_AllowEsc(OK:boolean);
begin
IO_Settings.IOEsc := OK;
end; {proc IO_AllowEsc}
Procedure IO_SoundBeeper(OK:boolean);
begin
IO_Settings.IO_BeepOn := OK;
end; {proc IO_SoundBeeper}
Procedure IO_ResetFields;
var I : integer;
begin
If not IO_Settings.IO_FieldsSet then abend(10,0);
For I := 1 to IO_Settings.TotalFields do
Dispose(FieldDefn[I]);
With IO_Settings do
begin
IO_FieldsSet := false;
TotalFields := 0;
IOEsc := false;
Displayed := false;
IO_Beepon := true;
IO_PutUnderline := true;
IO_Insert := false;
CurrentField := 1;
HelpAddress := 0;
end; {with}
end; { proc IO_ResetFields }
{
****************************
* Main Procedure *
****************************
}
Procedure IO_Edit(var Return_code : integer);
const finished : boolean = false;
var OldLine : line;
Procedure DisplayMessage(ID:byte);
var I,LocC : integer;
begin
For I := 1 to 80 do
begin
LocC := (I-1)*2 + (FieldDefn[ID]^.MsgY-1)*160;
OldLine[I].C := chr(mem[$b800:LocC]);
OldLine[I].A := mem[$B800:LocC+1];
end;
With FieldDefn[ID]^ do
WriteAT(MsgX,MsgY,IO_Settings.MsgF,IO_Settings.MsgB,Message);
end; {sub sub proc DisplayMessage}
Procedure RemoveMessage(ID:byte);
var I,LocC : integer;
begin
For I := 1 to 80 do
begin
LocC := (I-1)*2 + (FieldDefn[ID]^.MsgY-1)*160;
Mem[$B800:LocC] := ord(OldLine[I].C);
Mem[$B800:locC + 1] := OldLine[I].A;
end;
end; {sub sub proc RemoveMessage}
Procedure Change_Fields(ID:byte);
begin
LoLight(IO_Settings.CurrentField);
If FieldDefn[IO_Settings.CurrentField]^.MsgX > 0 then
RemoveMessage(IO_Settings.CurrentField);
If ID = 0 then
begin
Finished := true;
Return_Code := 0;
end
else
begin
IO_Settings.CurrentField := ID;
If IO_Settings.IO_Insert = true then {switch insert off}
InsertMode;
HiLight(IO_Settings.CurrentField);
If FieldDefn[IO_Settings.CurrentField]^.MsgX > 0 then
DisplayMessage(IO_Settings.CurrentField);
With FieldDefn[IO_Settings.CurrentField]^ do
GotoXY(CursorX,Y);
Ding;
end; {If ID = 0};
end; {proc change fields}
Procedure Erase_Field(ID:byte);
begin
with FieldDefn[ID]^ do
begin
Instring^ := '';
CursorX := CursorInit;
StrLocX := 1;
end;
end;
Procedure Global_Erase;
var I : integer;
begin
{MayBe paint an are you sure window}
For I := 1 to IO_Settings.TotalFields do
Erase_Field(I);
IO_DisplayFields;
IO_Settings.CurrentField := 1;
end;
Procedure Cursor_Right;
begin
With FieldDefn[IO_Settings.CurrentField]^ do
begin
If (StrLocX <= length(InString^)) and (StrLocX < StrLength) then
begin
StrLocX := StrLocX + 1;
Repeat
CursorX := CursorX + 1;
Until Format[CursorX + 1 - X] in FmtChars;
end;
GotoXY(CursorX,Y);
end; {with}
end; {Proc Cursor_Right}
Procedure Cursor_Left;
begin
With FieldDefn[IO_Settings.CurrentField]^ do
begin
If StrLocX > 1 then
begin
StrLocX := StrLocX - 1;
Repeat
CursorX := CursorX - 1;
Until Format[CursorX + 1 - X] in FmtChars;
end;
end; {with}
end; {Proc Cursor_left}
Procedure Delete_Char;
var
Temp : boolean;
I : integer;
begin
Temp := false; {insert a space if there are}
with FieldDefn[IO_Settings.CurrentField]^ do {non format characters}
begin
For I := 1 to length(Format) do
If not (Format[I] in FmtChars) then
Temp := true;
Delete(InString^,StrLocX,1);
If Temp = true then
Insert(' ',Instring^,StrlocX);
end; {with}
end; {Delete_Chars}
Procedure Backspaced;
begin
with FieldDefn[IO_Settings.CurrentField]^ do
begin
If StrLocX > 1 then
begin
Cursor_Left;
Delete(InString^,StrLocX,1);
end;
end; {with}
end; { Proc Backspaced }
Procedure Activity;
var K : char;
begin
Wait_for_KeyPress(K);
If K in [IOEsc1, IOEsc2, IOEnter, IOBackSp, IOTab] then Funckey := true;
If Funckey = true then
begin
Case K of
IOEsc1 : begin
If IO_Settings.IOEsc then
begin
Finished := true;
Return_Code := 1;
end
else
Ding;
end;
IOEsc2 : begin
If IO_Settings.IOEsc then
begin
Finished := true;
Return_Code := 2;
end
else
Ding;
end;
IOFinish : begin
Finished := true;
Return_code := 0;
end;
IORightFld,
IOTab,
IOEnter : Change_Fields(FieldDefn[IO_Settings.CurrentField]^.RightField);
IOLeftFld,
IOShiftTab :Change_Fields(FieldDefn[IO_Settings.CurrentField]^.LeftField);
IOBackSp : Backspaced;
IODel : Delete_Char;
IOLeft : Cursor_Left;
IORight : Cursor_Right;
IOUp : Change_Fields(FieldDefn[IO_Settings.CurrentField]^.UpField);
IODown : Change_Fields(FieldDefn[IO_Settings.CurrentField]^.DownField);
IOErase : Erase_Field(IO_Settings.CurrentField);
IOTotErase : Global_Erase;
IOIns : InsertMode;
IOHelp : If IO_Settings.HelpAddress <> 0 then
Jumpto(IO_Settings.HelpAddress);
else Ding;
end; {case}
end
else {not a function key}
If K in [#32..#126] then
with FieldDefn[IO_settings.CurrentField]^ do
begin
If Format[CursorX - X + 1] = '!' then K := upcase(K);
If ((K in ['0'..'9','.']) and (Format[CursorX - X + 1] = '#'))
or ((K in ['a'..'z','A'..'Z',' ',',','.',';',':']) and
(Format[CursorX - X + 1] = '@'))
or (Format[CursorX - X + 1] = '*')
or (Format[CursorX - X + 1] = '!') then
begin
If IO_Settings.IO_Insert then {in insert mode}
begin
If length(Instring^) < StrLength then
begin
Insert(K,Instring^,StrLocX);
Cursor_Right;
end
else Ding;
end
else {in overlay mode}
begin
Delete(Instring^,StrLocX,1);
Insert(K,Instring^,StrLocX);
Cursor_Right;
end; {If insert}
end
else Ding; {end if K in statement}
end; {with and big IF Funckey}
HiLight(IO_Settings.CurrentField);
With FieldDefn[IO_Settings.CurrentField]^ do
GotoXY(CursorX,Y);
end; {Proc Activity}
begin {IO_Edit}
If IO_Settings.Displayed = false then IO_DisplayFields;
Hilight(IO_Settings.CurrentField);
If FieldDefn[IO_Settings.CurrentField]^.MsgX > 0 then
DisplayMessage(IO_Settings.CurrentField);
GotoXY(FieldDefn[IO_Settings.CurrentField]^.CursorX,
FieldDefn[IO_Settings.CurrentField]^.Y);
Finished := false;
repeat
Activity
until Finished;
end; {IO_Edit}